home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
opbonus.arc
/
CALIBRAT.ARC
/
CALIBRAT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-20
|
19KB
|
695 lines
{$V-,F+}
{$I OPDEFINE.INC}
program Calibrate;
{-Define and edit BasePrinters}
uses
Dos,
OpInline,
OpString,
OpRoot,
OpCrt,
OpDos,
OpColor,
{$IFDEF UseMouse}
OpMouse,
{$ENDIF}
OpAbsFld,
OpFrame,
OpCmd,
OpField,
OpWindow,
OpSEdit,
OpSelect,
OpEntry,
OpPrnLow;
{$IFDEF UseMouse}
const
MouseChar : Char = #04;
{$ENDIF}
const
EsColors : ColorSet = (
TextColor : YellowOnBlue; TextMono : WhiteOnBlack;
CtrlColor : YellowOnBlue; CtrlMono : WhiteOnBlack;
FrameColor : CyanOnBlue; FrameMono : LtGrayOnBlack;
HeaderColor : WhiteOnCyan; HeaderMono : BlackOnLtGray;
ShadowColor : DkGrayOnBlack; ShadowMono : WhiteOnBlack;
HighlightColor : WhiteOnRed; HighlightMono : BlackOnLtGray;
PromptColor : LtGrayOnBlue; PromptMono : LtGrayOnBlack;
SelPromptColor : LtGrayOnBlue; SelPromptMono : LtGrayOnBlack;
ProPromptColor : DkGrayOnBlue; ProPromptMono : BlackOnBlack;
FieldColor : YellowOnBlue; FieldMono : LtGrayOnBlack;
SelFieldColor : BlueOnCyan; SelFieldMono : WhiteOnBlack;
ProFieldColor : DkGrayOnBlue; ProFieldMono : BlackOnBlack;
ScrollBarColor : CyanOnBlue; ScrollBarMono : LtGrayOnBlack;
SliderColor : CyanOnBlue; SliderMono : WhiteOnBlack;
HotSpotColor : BlackOnCyan; HotSpotMono : BlackOnLtGray;
BlockColor : YellowOnCyan; BlockMono : WhiteOnBlack;
MarkerColor : WhiteOnCyan; MarkerMono : BlackOnLtGray;
DelimColor : YellowOnBlue; DelimMono : WhiteOnBlack;
SelDelimColor : BlueOnCyan; SelDelimMono : WhiteOnBlack;
ProDelimColor : YellowOnBlue; ProDelimMono : WhiteOnBlack;
SelItemColor : YellowOnCyan; SelItemMono : BlackOnLtGray;
ProItemColor : LtGrayOnBlue; ProItemMono : LtGrayOnBlack;
HighItemColor : WhiteOnBlue; HighItemMono : WhiteOnBlack;
AltItemColor : WhiteOnBlue; AltItemMono : WhiteOnBlack;
AltSelItemColor : WhiteOnCyan; AltSelItemMono : BlackOnLtGray;
FlexAHelpColor : WhiteOnBlue; FlexAHelpMono : WhiteOnBlack;
FlexBHelpColor : WhiteOnBlue; FlexBHelpMono : WhiteOnBlack;
FlexCHelpColor : LtCyanOnBlue; FlexCHelpMono : BlackOnLtGray;
UnselXrefColor : YellowOnBlue; UnselXrefMono : LtBlueOnBlack;
SelXrefColor : WhiteOnCyan; SelXrefMono : BlackOnLtGray;
MouseColor : WhiteOnRed; MouseMono : BlackOnLtGray
);
{Entry field constants}
const
idUseBiosServices = 0;
idPrinterName = 1;
idLPTNumber = 2;
idPrinterTestNo = 3;
{Help index constants}
const
hiUseBiosServices = 1;
hiPrinterName = 2;
hiLPTNumber = 3;
hiPrinterTestNo = 4;
var
NormalAttr, HelpAttr, HelpLine : Byte;
ES : EntryScreen;
Status : Word;
Mask, HighScore : Byte;
UserRec : record
PrinterName : string[32];
UseBiosServices : Boolean;
LPTNumber : Byte;
PrinterTestNo : Byte;
end;
type
Str80 = String[80];
PrinterDesc =
record
Name : Str80;
PType : PrnType;
end;
TestType = (Online, Offline, OutOfPaper, PoweredOff);
ResultType = Array[TestType] of Byte;
const
TestPrompt : Array[TestType] of Str80 =
('Insure the printer is online and ready with paper loaded',
'Take the printer offline',
'Remove the paper from the printer',
'Turn the printer off');
Title =
'Calibrate - Creates BasePrinter Streams - by TurboPower Software';
OnlineWeight = 50;
OfflineWeight = 25;
PaperWeight = 20;
OffWeight = 5;
PrX1 = 10;
PrY1 = 20;
PrX2 = 70;
StreamFileName : String[79] = '';
function GetKey : Word;
begin
GetKey := OpCrt.ReadKeyWord;
end;
procedure DisplayErrorMsg(Msg : string);
{-Display an error message}
var
W, CursorSL, CursorXY : Word;
P : Pointer;
begin
{try to save screen}
if not SaveWindow(1, HelpLine, ScreenWidth, HelpLine, True, P) then begin
RingBell;
Exit;
end;
{Store cursor position and shape, then make it a fat cursor}
GetCursorState(CursorXY, CursorSL);
FatCursor;
{add to default message, if possible}
if Length(Msg) < 60 then
Msg := Msg+'. Press any key...';
{display error message and ring bell}
FastWrite(Center(Msg, ScreenWidth), HelpLine, 1, HelpAttr);
RingBell;
{flush keyboard buffer}
while KeyPressed do
W := GetKey;
{wait for keypress}
W := GetKey;
{Restore cursor position and shape}
RestoreCursorState(CursorXY, CursorSL);
{restore screen}
RestoreWindow(1, HelpLine, ScreenWidth, HelpLine, True, P);
end;
procedure PreEdit(ESP : EntryScreenPtr);
{-Called just before a field is edited}
var
S : String[80];
A : Byte;
begin
with ESP^ do
case GetCurrentID of
idUseBiosServices :
S := 'T to use BIOS Services, F to use DOS Services';
idPrinterName :
S := 'Enter the name of the file or device to send output to';
idLPTNumber :
S := 'Enter LPT Number (1, 2, or 3)';
idPrinterTestNo :
S := 'Enter printer test number (F10 for auto test selection)';
else
S := '';
end;
FastWrite(Center(S, ScreenWidth), HelpLine, 1, HelpAttr);
end;
procedure PostEdit(ESP : EntryScreenPtr);
{-Called just after a field has been edited}
begin
with ESP^, UserRec do
case GetCurrentID of
idUseBiosServices : begin
if UseBiosServices then begin
ChangeProtection(idLPTNumber, False);
ChangeProtection(idPrinterTestNo, False);
ChangeProtection(idPrinterName, True);
end
else begin
ChangeProtection(idLPTNumber, True);
ChangeProtection(idPrinterTestNo, True);
ChangeProtection(idPrinterName, False);
end;
DrawField(idPrinterName);
DrawField(idLPTNumber);
DrawField(idPrinterTestNo);
end;
idPrinterName : ;
idLPTNumber : ;
idPrinterTestNo : ;
end;
end;
procedure DisplayHelp(UnitCode : Byte; IdPtr : Pointer; HelpIndex : Word);
{-Display context sensitive help}
begin
end;
procedure IncChoice(var Value; ID : Word; Factor : Integer; var St : string);
{-Increment a multiple choice field value and convert it to a string}
begin
end;
procedure ErrorHandler(UnitCode : Byte; var ErrCode : Word; Msg : string);
{-Report errors}
begin
DisplayErrorMsg(Msg);
end;
procedure ClearHelpLine;
begin
FastWrite(CharStr(' ', ScreenWidth), HelpLine, 1, HelpAttr);
end;
procedure WriteHelpLine(S : String);
begin
FastWrite(Center(S, ScreenWidth), HelpLine, 1, HelpAttr);
end;
procedure Abort(S : String);
begin
GotoXY(1,25);
WriteLn(S);
RingBell;
Halt;
end;
procedure DialogBox(S : String);
var
Win : StackWindow;
XY, SL : Word;
begin
if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
ESColors, wClear+wBordered(*+wSoundEffects*)) then
Abort('Error initializing prompt window');
with Win do begin
EnableExplosions(5);
GetCursorState(XY, SL);
Draw;
HiddenCursor;
wFastCenter(S, 1, ESColors.TextColor);
wFastCenter('Press any key when ready', 2, ESColors.TextColor);
if ReadKey = #0 then ;
Erase;
RestoreCursorState(XY, SL);
Done;
end;
end;
function PromptUser(Prompt : String; MaxLen : Byte) : String;
var
Win : StackWindow;
XY, SL : Word;
SLE : SimpleLineEditor;
S : String;
begin
PromptUser := '';
if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
ESColors, wClear+wBordered(*+wSoundEffects*)) then
Abort('Error initializing prompt window');
with Win do begin
EnableExplosions(5);
Draw;
if not SLE.Init(EsColors) then
Exit;
S := '';
SLE.ReadString(Prompt, PrY1 + 1, PrX1 + 2, MaxLen,
(PrX2 - PrX1) - (Length(Prompt) + 2), S);
if (SLE.GetLastCommand = ccQuit) then
Exit;
PromptUser := S;
SLE.Done;
Erase;
Done;
end;
end;
function YesOrNo(Prompt : String;
Row, Col : Byte;
Default : Char) : Boolean;
var
P : Byte;
C : Char;
begin
Default := Upcase(Default);
P := Length(Prompt) + 3;
Prompt := Prompt + ' [' + Default + ']';
GotoXYAbs(Col + (Length(Prompt) - 2), Row);
FastWrite(Prompt, Row, Col, NormalAttr);
repeat
C := UpCase(Char(GetKey));
until C in ['N','Y',^M, ^[];
if C = ^M then
C := Default
else if C = ^[ then
C := 'N';
FastWrite(C, Row, Col + P - 1, NormalAttr);
YesOrNo := C = 'Y';
end;
function PromptYesOrNo(Prompt : String; Default : Boolean) : Boolean;
var
Win : StackWindow;
XY, SL : Word;
C : Char;
S : String;
begin
PromptYesOrNo := Default;
if not Win.InitCustom(PrX1, PrY1, PrX2, PrY1 + 2,
ESColors, wClear+wBordered(*+wSoundEffects*)) then
Abort('Error initializing prompt window');
with Win do begin
EnableExplosions(5);
GetCursorState(XY, SL);
Draw;
NormalCursor;
if Default then
C := 'Y'
else
C := 'N';
PromptYesOrNo := YesOrNo(Prompt, PrY1 + 1, PrX1 + 2, C);
Erase;
Done;
RestoreCursorState(XY, SL);
end;
end;
function BiosPrinterStatus(LPTNo : LPTType) : Byte;
{-Call BIOS Printer Status function for specified LPT number}
var
Regs : Registers;
begin
with Regs do begin
AH := 2;
DX := Word(LPTNo);
Intr($17, Regs);
BiosPrinterStatus := AH;
end;
end;
procedure TestSequence(LPTNo : LPTType; var Results : ResultType);
{-Perform the BIOS Printer tests}
var
Test : TestType;
begin
for Test := Online to PoweredOff do begin
DialogBox(TestPrompt[Test]);
Results[Test] := BiosPrinterStatus(LPTNo);
end;
end;
function FindAndScoreMask(Results : ResultType; var Mask : Byte) : Word;
{-Find best mask value and score its effectiveness}
var
Sc, M, I, HighSc, HighIndex : Byte;
const
Masks : Array[1..3] of Byte = ($90, $10, $A0);
begin
HighSc := 0;
HighIndex := 1;
for I := 1 to 3 do begin
M := Masks[I];
Sc := 0;
if M and Results[Online] = M then
Sc := OnlineWeight;
if M and Results[Offline] <> M then
Sc := Sc + OfflineWeight;
if M and Results[OutOfPaper] <> M then
Sc := Sc + PaperWeight;
if M and Results[PoweredOff] <> M then
Sc := Sc + OffWeight;
if Sc > HighSc then begin
HighIndex := I;
HighSc := Sc;
end;
end;
FindAndScoreMask := HighSc;
Mask := Masks[HighIndex];
end;
function PickBiosTest(LPTNo : LPTType;
var Mask : Byte; var HighScore : Byte) : Byte;
{-Perform test and analyze results}
var
Score : Array[1..4] of Byte;
Results : ResultType;
Test : TestType;
Sc, TestNo, I : Byte;
begin
{perform the printer tests}
TestSequence(LPTNo, Results);
{calculate score for each type of printer test}
Sc := 0;
if PrnTest1Prim(Word(Results[Online])) then
Sc := OnlineWeight;
if not PrnTest1Prim(Word(Results[Offline])) then
Sc := Sc + OfflineWeight;
if not PrnTest1Prim(Word(Results[OutOfPaper])) then
Sc := Sc + PaperWeight;
if not PrnTest1Prim(Word(Results[PoweredOff])) then
Sc := Sc + OffWeight;
Score[1] := Sc;
Sc := 0;
if PrnTest2Prim(Word(Results[Online])) then
Sc := OnlineWeight;
if not PrnTest2Prim(Word(Results[Offline])) then
Sc := Sc + OfflineWeight;
if not PrnTest2Prim(Word(Results[OutOfPaper])) then
Sc := Sc + PaperWeight;
if not PrnTest2Prim(Word(Results[PoweredOff])) then
Sc := Sc + OffWeight;
Score[2] := Sc;
Sc := 0;
if PrnTest3Prim(Word(Results[Online])) then
Sc := OnlineWeight;
if not PrnTest3Prim(Word(Results[Offline])) then
Sc := Sc + OfflineWeight;
if not PrnTest3Prim(Word(Results[OutOfPaper])) then
Sc := Sc + PaperWeight;
if not PrnTest3Prim(Word(Results[PoweredOff])) then
Sc := Sc + OffWeight;
Score[3] := Sc;
Score[4] := FindAndScoreMask(Results, Mask);
{find HighScore score and record test number}
HighScore := Score[1];
TestNo := 1;
for I := 2 to 4 do
if Score[I] > HighScore then begin
HighScore := Score[I];
TestNo := I;
end;
{if our best score isn't better than a cutoff, then use no test}
if HighScore < (OnlineWeight + 1) then
TestNo := 0;
PickBiosTest := TestNo;
end;
function InitEntryScreen : Word;
{-Initialize entry screen generated by MAKESCRN}
const
Frame1 = '╓╙╖╜──║║';
WinOptions = wBordered+wClear+wUserContents(*+wSoundEffects*);
begin
with EntryCommands do begin
AddCommand(ccUser0, 1, $4400, 0);
AddCommand(ccUser1, 1, $2D00, 0);
end;
with ES do begin
if not InitCustom(5, 9, 75, 16, EsColors, WinOptions) then begin
InitEntryScreen := InitStatus;
Exit;
end;
wFrame.SetFrameType(Frame1);
EnableExplosions(5);
wFrame.AddShadow(shBR, shSeeThru);
wFrame.AddHeader('Printer Information', heTC);
SetWrapMode(WrapAtEdges);
SetPreEditProc(PreEdit);
SetPostEditProc(PostEdit);
SetErrorProc(ErrorHandler);
EntryCommands.SetHelpProc(DisplayHelp);
{idUseBiosServices:}
AddBooleanField(
'Use BIOS Services :', 2, 2,
'B', 2, 25,
hiUseBiosServices, UserRec.UseBiosServices);
{idPrinterName:}
esFieldOptionsOn(efClearFirstChar);
AddStringField(
'Enter name :', 3, 2,
CharStr('X', 32), 3, 25, 32,
hiPrinterName, UserRec.PrinterName);
{idLPTNumber:}
AddByteField(
'Enter LPT Number :', 4, 2,
'9', 4, 25,
hiLPTNumber, 1, 3, UserRec.LPTNumber);
{idPrinterTestNo:}
AddByteField(
'Enter Printer Test:', 5, 2,
'9', 5, 25,
hiPrinterTestNo, 0, 4, UserRec.PrinterTestNo);
InitEntryScreen := GetLastError;
end;
end;
function DoAuto : Byte;
var
TestNo : Byte;
begin
TestNo := PickBiosTest(LPTType(UserRec.LPTNumber-1), Mask, HighScore);
if TestNo = 0 then begin
Sound(110);
Delay(800);
NoSound;
DialogBox('No printer test is adequate! Using test number 0.');
end;
DoAuto := TestNo;
end;
procedure ProcessPrinter;
{-Store the stream}
var
Stm : BufIDStream;
BP : BasePrinterPtr;
T : PrnType;
ErrorCode : Word;
begin
with UserRec do
if UseBiosServices then begin
BP := New(BiosPrinterPtr, InitCustom(LPTType(LPTNumber-1),
PrinterTestNo,
Mask));
if BP = NIL then begin
DialogBox('Unable to create BiosPrinter object');
Exit;
end;
end
else begin
if StUpCase(PrinterName) = 'PRN' then
T := Prn
else
T := DiskFile;
BP := New(DosPrinterPtr, Init(PrinterName, T));
if BP = NIL then begin
DialogBox('Unable to create DosPrinter object');
Exit;
end;
end;
if not Stm.Init(StreamFileName, SCreate, 1024) then begin
DialogBox('Can not open stream file, aborting...');
Exit;
end;
with Stm do begin
RegisterHier(DosPrinterStream);
RegisterHier(BiosPrinterStream);
PutPtr(BP);
ErrorCode := GetStatus;
Done;
end;
if ErrorCode = 0 then
DialogBox('Stream successfully written')
else
DialogBox('Error writing stream. Aborting...');
end;
procedure DoEntryScreen;
var
AllDone : Boolean;
ExitCmd : Word;
begin
{$IFDEF UseMouse}
if MouseInstalled then
with EsColors do begin
{activate mouse cursor}
SoftMouseCursor($0000, (ColorMono(MouseColor, MouseMono) shl 8)+
Byte(MouseChar));
ShowMouse;
{enable mouse support}
EntryCommands.cpOptionsOn(cpEnableMouse);
end;
{$ENDIF}
{initialize entry screen}
Status := InitEntryScreen;
if Status <> 0 then begin
WriteLn('Error initializing entry screen: ', Status);
Halt(1);
end;
{initialize user record}
FillChar(UserRec, SizeOf(UserRec), 0);
with UserRec do begin
UseBiosServices := True;
LPTNumber := 1;
PrinterTestNo := 1;
end;
ES.ChangeProtection(idPrinterName, True);
AllDone := False;
{test entry screen}
repeat
ES.Process;
ExitCmd := ES.GetLastCommand;
case ExitCmd of
ccQuit : AllDone :=
PromptYesOrNo('Really exit without saving?', False);
ccError : begin
AllDone := True;
DialogBox('An error has occurred processing the entry screen');
end;
ccUser1 : AllDone := True;
ccDone : begin
ProcessPrinter;
AllDone := True;
end;
ccUser0 : if ES.GetCurrentID = idPrinterTestNo then begin
UserRec.PrinterTestNo := DoAuto;
ES.SetLastCommand(ccNextField);
end;
end;
until AllDone;
ES.Erase;
ES.Done;
{$IFDEF UseMouse}
HideMouse;
{$ENDIF}
end;
function GetStreamName : Boolean;
begin
GetStreamName := False;
WriteHelpLine('Enter the name of the stream file to create');
StreamFileName := PromptUser('File name: ', SizeOf(StreamFileName) - 1);
if ExistFile(StreamFileName) then
if not PromptYesOrNo('File exists, overwrite?', False) then
Exit;
GetStreamName := StreamFileName <> '';
end;
begin
TextChar := '░';
ClrScr;
case CurrentMode of
2, 7 : begin
HelpAttr := ESColors.FlexBHelpMono;
NormalAttr := ESColors.TextMono;
end;
else begin
HelpAttr := ESColors.FlexBHelpColor;
NormalAttr := ESColors.TextColor;
end;
end;
FastWrite(Center(Title, ScreenWidth), 1, 1, HelpAttr);
HelpLine := ScreenHeight;
ClearHelpLine;
if GetStreamName then
DoEntryScreen;
TextAttr := $07;
ClrScr;
end.